home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / CMDLG7 / COMOSAMP.PAS < prev    next >
Pascal/Delphi Source File  |  1992-12-10  |  12KB  |  480 lines
  1.  
  2. {***************************************************}
  3. {                                                   }
  4. {   Turbo Pascal for Windows                        }
  5. {   Windows 3.1 Common Dialogs Demo Program         }
  6. {                                                   }
  7. {   Copyright (c) 1992 by Borland International     }
  8. {   modifications for tCommonDlg object by          }
  9. {%%                              Juancarlo A±ez     }
  10. {%%                              [73000, 1064]      }
  11. {%%                               August 1992        } 
  12. {                                                   }
  13. {***************************************************}
  14.  
  15.  
  16. PROGRAM CommDlgs;
  17.  
  18. { This program demonstrates the use of several new Windows 3.1
  19.   features: The Common Dialogs (for Font and Color selection),
  20.   True Type, and Playing sounds.
  21. }
  22.  
  23. {%% THIS PROGRAM ALSO SHOWS HOW TO USE THE tCommonDlg OBJECT AND ITS
  24.     DESCENDANTS, AND THE PRN31 UNIT, A WIN 3.1 AWARE VERSION OF
  25.     PRINTER.PAS IN CIS LIB 8
  26.  
  27.     I TESTED THIS APP WITH THE FOLOWING OPTIONS
  28. }
  29. {$A+,B-,D+,F-,G+,I+,L+,N+,R+,S+,V-,W-,X+}
  30.  
  31. USES
  32.   WinCrt,
  33.   WinDos,
  34.   Strings,
  35.   WinTypes,
  36.   WinProcs,
  37.   Objects,
  38.   OWindows,
  39.   CommDlg,
  40.   MMSystem,
  41.   BWCC,
  42.  
  43.   {following  units added by me
  44.   {
  45.     \\\
  46.    -(j)-
  47.      /juanca
  48.   }
  49.   ComonDlg,
  50.   fNameDlg,  { tFileNameDlg OBJECT }
  51.   FontDlg,
  52.   MyPrn_,    { tMyPrinter   OBJECT  that uses BWCC}
  53.   MyOpen_,   { tMyOpenDlg   OBJECT  that uses BWCC}
  54.   UsrWin_,
  55.   Port_
  56.   ;
  57.  
  58.   {
  59.     \\\
  60.    -(j)-
  61.      /juanca
  62.   }
  63.   {changed resource file }
  64. {$R COMOSAMP }
  65. {$I CDLG.INC } {just some little id_...Whatever }
  66.  
  67. const
  68.  
  69. { Resource IDs }
  70.  
  71.   id_Menu    = 100;
  72.   id_About   = 100;
  73.   id_Icon    = 100;
  74.  
  75. { Menu command IDs }
  76.  
  77.   cm_FileOpen = 101;
  78.   cm_Color    = 103;
  79.   cm_Font     = 104;
  80.  
  81.  
  82.   {
  83.     \\\
  84.    -(j)-
  85.      /juanca
  86.   }
  87.   {new commands }
  88.   cm_FilePrint        = 110;
  89.   cm_FilePrinterSetup = 111;
  90.   cm_FileUseBWCC      = 112;
  91.  
  92. { Other Constants }
  93.  
  94.   FlagWidth   = 251;
  95.   FlagHeight  = 180;
  96.  
  97. type
  98.  
  99. { Filename string }
  100.  
  101.   TFilename = array [0..255] of Char;
  102.  
  103. { Application main window }
  104.  
  105.   PCommDlgsWindow = ^TCommDlgsWindow;
  106.   TCommDlgsWindow = Object(tUsrWin)  {base type changed to tUsrWin }
  107.                                      {  \\\                        }
  108.     fontPointsBy10 :Longint;         { -(j)-                       }
  109.     ALogFont       : TLogFont;            {   /juanca                   }
  110.     ColorRef       : LongInt;
  111.     myPrinter      : tMyPrinter;
  112.     useBWCC        : Boolean;
  113.  
  114.     constructor Init(AParent: PWindowsObject; AName: PChar);
  115.     destructor  Done; virtual;
  116.  
  117.     procedure MakeDefaultFont;
  118.     procedure SetupWindow; virtual;
  119.  
  120.   {
  121.     \\\
  122.    -(j)-
  123.      /juanca
  124.   }
  125.   { removed the paint method, now use upaint thats compatible with printing}
  126.     procedure
  127.     upaint(dc :pPort; bound :tRect; erased :Boolean);
  128.       virtual;
  129.  
  130.     procedure CMColor(var Msg: TMessage);
  131.       virtual cm_First + cm_Color;
  132.     procedure CMFileOpen(var Msg: TMessage);
  133.       virtual cm_First + cm_FileOpen;
  134.     procedure CMFonts(var Msg: TMessage);
  135.       virtual cm_First + cm_Font;
  136.  
  137.   {
  138.    \\\
  139.    -(j)-
  140.      /juanca
  141.   }
  142.   { new commands }
  143.     procedure
  144.     CMFilePrint(var msg :tMessage);
  145.       virtual
  146.         cm_First+cm_FilePrint;
  147.     procedure
  148.     CMFilePrinterSetup(var msg :tMessage);
  149.       virtual
  150.         cm_First+cm_FilePrinterSetup;
  151.     procedure
  152.     CMFileUseBWCC(var msg :tMessage);
  153.       virtual
  154.         cm_First+cm_FileUseBWCC;
  155.   END; {tCommonDlgsWindow }
  156.  
  157. { Application object }
  158.  
  159.   PCommDlgApp = ^TCommDlgApp;
  160.   TCommDlgApp = Object(TApplication)
  161.     procedure InitMainWindow; virtual;
  162.   end;
  163.  
  164.  
  165.  
  166.  
  167. { Initialized globals }
  168.  
  169. const
  170.   DemoTitle: PChar = 'Common Dialogs Demo';
  171.  
  172. { Global variables }
  173.  
  174. var
  175.   App: TCommDlgApp;
  176.  
  177.  
  178.  
  179.   {
  180.     \\\
  181.    -(j)-
  182.      /juanca
  183.   }
  184.   {NOTICE THIS FUNCTION
  185.   it takes a tLogFont *as value parameter* (no changes to original) and
  186.   creates a GDI font object adecuate for the DeviceContext
  187.   taking a PointSize x 10  parameter
  188.   }
  189.   FUNCTION
  190.   createFontInPointsForDC(hdc :tHandle; px10Size :Word; lfont :tLogFont):tHandle;
  191.     begin
  192.       lFont.lfHeight := -(px10Size*getDeviceCaps(hdc, LOGPIXELSY)) div 720;
  193.       createFontInPointsForDC  := createFontIndirect(lFont);
  194.     end;
  195.  
  196.  
  197. { TCommDlgsWindow Methods }
  198.  
  199. { Constructs an instance of TCommDlgsWindow.  Loads the menu and
  200.   initialize the wave file's "FileName" and the text's initial RGB
  201.   color value.
  202. }
  203. constructor TCommDlgsWindow.Init(AParent: PWindowsObject; AName: PChar);
  204. begin
  205.   inherited Init(AParent, AName);
  206.   Attr.Menu:= LoadMenu(HInstance, PChar(id_Menu));
  207.  
  208.   ColorRef := RGB(0, 0, 255);
  209.   fontPointsBy10 := 720;
  210.   myPrinter.init;
  211.   useBWCC   := FALSE;
  212. end;
  213.  
  214. { Destroys an instance of the TCommDlgsWindow by disposing of its
  215.   "FlagMap" image and Font.  Then calls on ancestral destructor to
  216.   complete the shutdown.
  217. }
  218. destructor TCommDlgsWindow.Done;
  219. begin
  220.   myPrinter.done;
  221.   inherited Done;
  222. end;
  223.  
  224. { Sets up an Italic, Times New Roman, font handle used as the default
  225.   Font by TCommDlgsWindow in its Paint method.
  226. }
  227. procedure TCommDlgsWindow.MakeDefaultFont;
  228. begin
  229.   FillChar(ALogFont, SizeOf(TLogFont), #0);
  230.   with ALogFont do
  231.   begin
  232.     lfHeight        := 96;     {Make a large font                 }
  233.     lfWeight        := 700;    {Indicate a Bold attribute         }
  234.     lfItalic        := 1;      {Non-zero value indicates italic   }
  235.     lfUnderline     := 1;      {Non-zero value indicates underline}
  236.     lfOutPrecision  := Out_Stroke_Precis;
  237.     lfClipPrecision := Clip_Stroke_Precis;
  238.     lfQuality       := Default_Quality;
  239.     lfPitchAndFamily:= Variable_Pitch;
  240.     StrCopy(lfFaceName, 'Times New Roman');
  241.   end;
  242. end;
  243.  
  244. { Establishes the font and the "FlagMap" bitmap image used in
  245.   TCommDlgsWindow's Paint method.  The FlagMap is held as an instance
  246.   variable until the window is closed.
  247. }
  248. procedure TCommDlgsWindow.SetUpWindow;
  249. begin
  250.   inherited SetupWindow;
  251.   MakeDefaultFont;
  252. end;
  253.  
  254. { Displays the bitmap held in "FlagMap".  Then surrounds this flag map
  255.   with the string 'TP Win 3.1' in the selected font and text color.
  256. }
  257. procedure TCommDlgsWindow.upaint(dc :pPort; bound :tRect; erased :Boolean);
  258. var
  259.   S        : array [0..100] of Char;
  260.   paintDC  : HDC;
  261.   Dims     : LongInt;
  262.   oldFont,
  263.   font     : tHandle;
  264. begin
  265.   paintDC := dc^.context;
  266.  
  267.   { formula for calculating fontHeight for WYSYWIG,
  268.     size := -(PIXELSxINCH * Points)/72  }
  269.   font := createFontInPointsForDC(paintDC, fontPointsBy10, aLogFont);
  270.  
  271.   StrCopy(S, 'TP ');
  272.   oldFont := SelectObject(PaintDC, font);
  273.   SetTextColor(PaintDC, ColorRef);
  274.   TextOut(PaintDC, 0, 0, S, StrLen(S));
  275.   Dims := GetTextExtent(PaintDC, S, StrLen(S));
  276.  
  277.  
  278.   StrCopy(S, ' Win 3.1');
  279.   TextOut(PaintDC, (LoWord(Dims) ), 0, S, StrLen(S));
  280.  
  281.   deleteObject(selectObject(paintDC, oldFont));
  282. end;
  283.  
  284. { Displays the "Open File Dialog" from Common dialogs and permit the user
  285.   to select from among the available Wave files.  Then play the sound
  286.   found in the file using "SndPlaySound".
  287. }
  288. procedure TCommDlgsWindow.CMFileOpen(var Msg: TMessage);
  289. var
  290.   {
  291.     \\\
  292.    -(j)-
  293.      /juanca
  294.   }
  295.   { removed declarations }
  296. {$ifdef NOT_NEEDED}
  297.   OpenFN      : TOpenFileName;
  298.   Filter      : array [0..100] of Char;
  299.   FullFileName: TFilename;
  300. {$endif}
  301.   WinDir      : array [0..145] of Char;
  302.   dlg         :pMyOpenDlg;
  303. begin
  304.   GetWindowsDirectory(WinDir, SizeOf(WinDir));
  305.   SetCurDir(WinDir);
  306.  
  307.   if useBWCC
  308.   then
  309.     dlg := new(pMyOpenDlg, init(@Self, 'OPEN_DLG', TRUE)) { TRUE means OpenDlg, FALSE SaveAsDlg }
  310.   else
  311.     dlg := new(pMyOpenDlg, init(@Self, nil, TRUE)); { TRUE means OpenDlg, FALSE SaveAsDlg }
  312.   if dlg <> nil
  313.   then begin
  314.     if (dlg^.execute = idOk) 
  315.     then
  316.       with dlg^, openFileName
  317.       do begin
  318.         if strComp(filePath+nFileExtension, 'WAV') = 0
  319.         then
  320.           SndPlaySound(dlg^.filePath, 1);   {Second parameter must be 1}
  321.         case option
  322.         of
  323.           id_Superb :
  324.             messageBox( hwindow,
  325.                         'So you like my dialogs...Thanks :->',
  326.                         'Juanca',
  327.                         mb_IconExclamation or mb_Ok); 
  328.           id_JustOk :
  329.             messageBox( hwindow,
  330.                         'My Dlg''s are just ok?'#10+
  331.                         'Well...I diddn''t really work too hard onthem :-)',
  332.                         'Juanca',
  333.                         mb_IconQuestion or mb_Ok);
  334.           id_YourOwn:
  335.             messageBox( hwindow,
  336.                         'If you don''t like theese...'#10+
  337.                         'Better go for it...start writing your own Common Dlgs :-\',
  338.                         'Juanca',
  339.                         mb_IconStop or mb_Ok);
  340.         end
  341.       end;
  342.     dlg^.free
  343.   end
  344. end;
  345.  
  346. { Displays the "Choose Color" dialog from the common dialogs unit.
  347.   Permits an initial value to be inserted and custom colors to be
  348.   developed. Note, custom colors are not used by the "ChooseFont"
  349.   dialog from common dialogs.
  350. }
  351. procedure TCommDlgsWindow.CMColor(var Msg: TMessage);
  352. type
  353.   TLongAry = array [0..15] of Longint;
  354. const
  355.   { Establishes a set of custom colors in 15 shades of blue }
  356.   CustColors: TLongAry = (
  357.     $000000, $100000, $200000, $300000,
  358.     $400000, $500000, $600000, $700000,
  359.     $800000, $900000, $A00000, $B00000,
  360.     $C00000, $D00000, $E00000, $F00000);
  361. var
  362.   ChooseClr: TChooseColor;
  363.   i        : Integer;
  364. begin
  365.   with ChooseClr do
  366.   begin
  367.     HWndOwner   := HWindow;
  368.     lStructSize := Sizeof(TChooseColor);
  369.     rgbResult   := ColorRef;
  370.     lpCustColors:= PLongint(@CustColors);
  371.     Flags       := cc_FullOpen or cc_RGBInit;
  372.       {Allow custom colors and the initialization through rgbResult}
  373.   end;
  374.   if not ChooseColor(ChooseClr) then
  375.     Exit;
  376.   ColorRef := ChooseClr.RGBResult;
  377.   InvalidateRect(HWindow, nil, True);
  378. end;
  379.  
  380. { Displays the ChooseFont dialog to permit the selection of a font which
  381.   is returned as a TLogFont.  Then a font handle is created from this
  382.   logical font information.
  383. }
  384. procedure TCommDlgsWindow.CMFonts(var Msg: TMessage);
  385. var
  386.   ChooseRec: TChooseFont;
  387.   Colors   : LongInt;
  388.   Style    : array [0..100] of Char;
  389.   TempFont : TLogFont;
  390.   result   : Longint;
  391.   cfdlg    : pChooseFontDlg;
  392. begin
  393.   FillChar(ChooseRec, SizeOf(ChooseRec), #0);
  394.   with ChooseRec do
  395.   begin
  396.     lStructSize:= SizeOf(TChooseFont);
  397.     hdc        := myPrinter.context;
  398.     lpLogFont  := @ALogFont;
  399.     Flags      := cf_Both or cf_WYSIWYG or cf_Effects or cf_InitToLogFontStruct;
  400.     rgbColors  := ColorRef;
  401.     lpszStyle  := Style;
  402.     iPointSize := fontPointsBy10;
  403.   end;
  404.  
  405.  
  406.   {
  407.      \\\
  408.     -(j)-
  409.       /juanca
  410.   }
  411.   { this is the easy way to change the dialog "look"}
  412.   if useBWCC
  413.   then begin
  414.     cfdlg := new(pChooseFontDlg, init(@Self, 'CHOOSEF_31', @chooseRec));
  415.     if (cfdlg = nil) or (cfdlg^.execute <> id_Ok)
  416.     then
  417.         Exit;
  418.   end
  419.   else if not ChooseFont(ChooseRec)
  420.   then begin
  421.     result := CommDlgExtendedError; { juanca: this is so you can wath with a debugger }
  422.     Exit;
  423.   end;
  424.  
  425. { Update the Font and Color data fields, then cause the window to be
  426.   repainted.
  427. }
  428.   ColorRef:= ChooseRec.rgbColors;
  429.   fontPointsBy10 := chooseRec.iPointSize;
  430.   InvalidateRect(HWindow, nil, True);
  431. end;
  432.  
  433.  
  434.     procedure
  435.     TCommDlgsWindow.
  436.     {}
  437.     CMFilePrint(var msg :tMessage);
  438.       begin
  439.         myPrinter.print(@self, 'JUANCA')
  440.       end;
  441.  
  442.     procedure
  443.     TCommDlgsWindow.
  444.     {}
  445.     CMFilePrinterSetup(var msg :tMessage);
  446.       begin
  447.         myPrinter.setup(@self)
  448.       end;
  449.  
  450.     procedure
  451.     TCommDlgsWindow.
  452.     {}
  453.     CMFileUseBWCC(var msg :tMessage);
  454.       begin
  455.         useBWCC := not useBWCC;
  456.         if useBWCC
  457.         then
  458.           checkMenuItem(attr.menu, cm_FileUseBWCC, mf_ByCommand or mf_Checked)
  459.         else
  460.           checkMenuItem(attr.menu, cm_FileUseBWCC, mf_ByCommand);
  461.         myPrinter.setBWCCUse(useBWCC)
  462.       end;
  463.  
  464.  
  465. { TCommDlgApp Methods }
  466.  
  467. procedure TCommDlgApp.InitMainWindow;
  468. begin
  469.   MainWindow := New(PCommDlgsWindow, Init(nil, Application^.Name));
  470. end;
  471.  
  472.  
  473. { Main program }
  474.  
  475. begin
  476.   App.Init(DemoTitle);
  477.   App.Run;
  478.   App.Done;
  479. end.
  480.